home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / strategy.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  10.2 KB  |  271 lines
  1. (herald (back_end strategy)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define (variable-known var)
  28.   (if (not (variable? var))
  29.       nil
  30.       (let ((type (variable-type var)))
  31.         (cond ((and (node? type) (lambda-node? type))
  32.                type)
  33.               (else nil)))))
  34.  
  35. (define (variable-y-lambda var)
  36.   (node-parent (node-parent (variable-binder var))))
  37.  
  38. (define (object-lambda? node)
  39.   (and (lambda-node? node)
  40.        (primop-ref? (call-proc (lambda-body node)) primop/proc+handler)))
  41.  
  42. (define (let-lambda? l)
  43.   (lambda-node? (call-proc (node-parent l))))
  44.  
  45. (define (call-in-body? proc node)
  46.   (fx> (lambda-trace proc) (lambda-trace (node-parent node))))
  47.  
  48. (define-local-syntax (define-lambda-strategies . strategies)
  49.   `(block ,@(map! (lambda (strat)      
  50.                     (let ((strat (concatenate-symbol 'strategy/ strat)))
  51.                       `(define-constant ,strat ',strat)))
  52.                    strategies)))
  53.  
  54.  
  55. (define-lambda-strategies open label ezclose vframe stack heap hack)
  56.  
  57. (define (set-lambda-strategy! node)
  58.   (cond ((lambda-strategy node))
  59.         (else                
  60.          (set (lambda-strategy node)
  61.               (let* ((parent (node-parent node))
  62.                      (proc   (call-proc parent)))
  63.                 (cond ((or (and (fx<= 2 (call-exits parent))
  64.                                 (call-exit? node))
  65.                            (and (call-exit? node)
  66.                                 (primop-node? proc)))
  67.                        strategy/open)
  68.                       ((call-exit? node)
  69.                        strategy/stack)
  70.                       (else
  71.                        strategy/heap)))))))
  72.  
  73. (define db cons)
  74. (define (lambda-depth lam) (car (lambda-db lam)))
  75. (define (lambda-trace lam) (cdr (lambda-db lam)))
  76.  
  77. (define (analyze-top node)
  78.   (analyze-lambda ((call-arg 1) (lambda-body node)) 0 0))
  79.                                    
  80. (define (analyze-lambda node depth -trace)
  81.   (set (lambda-db node) (db depth -trace))
  82.   (set-lambda-strategy! node)
  83.   (let ((tr (analyze-body (lambda-body node) depth -trace)))
  84.     (walk sort-by-db (if (continuation? node)
  85.                          (lambda-variables node)
  86.                          (cdr (lambda-variables node))))
  87.     (fx+ tr 1)))
  88.  
  89.                              
  90. (define (analyze-body node depth -trace)
  91.   (let ((proc (call-proc node)))
  92.     (cond ((primop-node? proc)
  93.            (select (primop-value proc) 
  94.              ((primop/conditional)
  95.               (analyze-if node depth -trace))
  96.          ((primop/computed-goto)
  97.           (analyze-computed-goto node depth -trace))
  98.              ((primop/Y) 
  99.               (analyze-Y ((call-arg 1) node) ((call-arg 2) node) depth -trace))                
  100.              ((primop/undefined-effect) -trace)
  101.              (else
  102.               (really-analyze-body (call-args node) depth -trace))))
  103.           ((lambda-node? proc)
  104.            (analyze-let node depth -trace))   
  105.           (else  
  106.            (really-analyze-body (call-args node) depth -trace)))))
  107.  
  108.  
  109. (define (really-analyze-body args depth -trace)
  110.   (iterate loop ((-trace -trace) (args args))
  111.     (cond ((null? args) -trace)
  112.           ((lambda-node? (car args))             
  113.            (loop (analyze-lambda (car args) (fx+ depth 1) -trace) 
  114.                  (cdr args)))
  115.           (else
  116.            (loop -trace (cdr args))))))
  117.  
  118. (define (analyze-computed-goto node depth -trace)
  119.   (iterate loop ((i (call-exits node)) (next (call-args node)) (-trace -trace))
  120.     (cond ((fx= i 0) -trace)
  121.       ((not (lambda-node? (car next)))
  122.        (bug "Non-lambda in computed-goto ~s" node))
  123.       (else
  124.        (loop (fx- i 1)
  125.          (cdr next)
  126.          (analyze-lambda (car next) (fx+ depth 1) -trace))))))
  127.  
  128. (define (analyze-if node depth -trace)
  129.   (receive (trac other) (determine-if-trace ((call-arg 1) node) ((call-arg 2) node))
  130.     (let ((-trace (if (lambda-node? trac)
  131.                        (analyze-lambda trac (fx+ depth 1) -trace)
  132.                        -trace)))
  133.       (if (lambda-node? other)
  134.           (analyze-lambda other (fx+ depth 1) -trace)
  135.           -trace))))
  136.                                       
  137.  
  138. (define (determine-if-trace th el)
  139.   (cond ((leaf-node? th)
  140.          (return el th))
  141.         ((leaf-node? el)
  142.          (return th el))
  143.         (else
  144.          (let ((th-body (lambda-body th))
  145.                (el-body (lambda-body el)))
  146.            (cond ((fx= (call-exits th-body) 0)
  147.           (cond ((fxn= (call-exits el-body) 0)
  148.              (return el th))
  149.             ((and (leaf-node? (call-proc th-body))
  150.                   (variable-known (leaf-value (call-proc th-body))))
  151.              (return th el))
  152.             (else
  153.              (return el th))))
  154.                  ((fx= (call-exits el-body) 0)
  155.           (return th el))
  156.                  ((primop-node? (call-proc th-body))
  157.                   (return th el))
  158.                  (else 
  159.                   (return el th)))))))
  160.              
  161.  
  162. (define (analyze-let let-node depth -trace)
  163.   (if (lambda-rest-var (call-proc let-node)) 
  164.       (bug "nary-let not implemented yet"))
  165.   (let ((lambdas (call-proc+args let-node)))
  166.     (set (lambda-strategy (car lambdas)) strategy/open)
  167.     (walk set-let-strategy!
  168.           (lambda-variables (car lambdas))
  169.           (cdr lambdas))            
  170.     (analyze-lambda (car lambdas) (fx+ depth 1) -trace)
  171.     (let ((lambdas (filter lambda-node? (cdr lambdas))))
  172.       (cond ((null? lambdas) (fx+ -trace 1))
  173.             (else                  
  174.              (really-analyze-body lambdas (fx+ depth 1) (fx+ -trace 1)))))))
  175.  
  176. (define (set-let-strategy! var arg)
  177.   (cond ((and var (lambda-node? arg))
  178.          (set (variable-type var) arg)
  179.          (set (lambda-strategy arg)
  180.               (cond ((and (all-refs-are-calls? var) 
  181.                           (not (and (lambda-rest-var arg)
  182.                                     (used? (lambda-rest-var arg)))))
  183.                      strategy/label)
  184.                     ((continuation? arg)       
  185.                      strategy/label)
  186.                     (else 
  187.                      strategy/heap))))))
  188.        
  189.  
  190. (define (analyze-Y cont master depth -trace)
  191.   (let* ((lambdas (call-args (lambda-body master)))
  192.          (strategy (get-labels-strategy master)))
  193.     (walk (lambda (var l) 
  194.             (set (lambda-strategy l) strategy)
  195.             (if var (set (variable-type var) l)))
  196.           (cdr (lambda-variables master))
  197.           (cdr lambdas))                                  
  198.     (set (lambda-strategy master) strategy)
  199.     (set (lambda-strategy (car lambdas)) strategy/open)
  200.     (let ((tr (cond ((not (lambda-node? cont)) -trace)
  201.                     ((and (eq? strategy strategy/label)
  202.               (constant-continuation? master)
  203.               (check-continuation-refs lambdas
  204.                            (lambda-variables master)))
  205.                      (set (lambda-strategy cont) strategy/label)
  206.                      (walk (lambda (l)
  207.                              (set (variable-type (lambda-cont-var l)) cont))
  208.                            (cdr lambdas))
  209.                      (analyze-lambda cont (fx+ depth 1) -trace))
  210.             (else
  211.                      (set (lambda-strategy cont) strategy/stack)
  212.                      (analyze-lambda cont (fx+ depth 1) -trace)))))
  213.       (really-analyze-body lambdas (fx+ depth 1) tr))))
  214.  
  215. (define (check-continuation-refs l vars)
  216.   (every? (lambda (l)
  217.         (every? (lambda (ref)
  218.               (or (eq? (node-role ref) call-proc)
  219.               (let ((proc (call-proc (node-parent ref))))
  220.                 (memq? (reference-variable proc) vars))))
  221.             (variable-refs (lambda-cont-var l))))
  222.       l))
  223.  
  224.           
  225.  
  226. (define (get-labels-strategy master)
  227.   (cond ((or (not (every? all-refs-are-calls? (cdr (lambda-variables master))))
  228.              (any? lambda-rest-var (call-args (lambda-body master))))
  229.          strategy/heap)
  230.         (else
  231.          strategy/label)))
  232.  
  233.  
  234.  
  235. (define (ezclose-allowed? l)
  236.   (eq? (lambda-db (node-parent (node-parent l))) 'ezclose))
  237.  
  238. (define (sort-by-db var)
  239.  (if var
  240.   (set (variable-refs var)
  241.        (sort-list! (variable-refs var)
  242.               (lambda (ref1 ref2)
  243.                 (let ((l1 (node-parent (node-parent ref1)))
  244.                       (l2 (node-parent (node-parent ref2))))
  245.                   (cond ((fx< (lambda-trace l1) (lambda-trace l2)) t)
  246.                         ((fx> (lambda-trace l1) (lambda-trace l2)) nil)
  247.                         (else
  248.                          (fx<= (lambda-depth l1) (lambda-depth l2))))))))))
  249.               
  250.                  
  251. (define (constant-continuation? node)
  252.   (every? (lambda (var)
  253.             (every? (lambda (ref)
  254.                       (let ((cont ((call-arg 1) (node-parent ref))))
  255.                         (and (leaf-node? cont) 
  256.                              (eq? (node-parent (node-parent
  257.                                   (variable-binder (leaf-value cont))))
  258.                        node))))
  259.                     (variable-refs var)))
  260.           (cdr (lambda-variables node))))
  261.           
  262.  
  263. (define (labels-lambda? node)
  264.   (labels-master-lambda? (node-parent (node-parent node))))
  265.  
  266. (define (labels-master-lambda? node)
  267.   (and (eq? (node-role node) (call-arg 2))
  268.        (primop-ref? (call-proc (node-parent node)) primop/y)))
  269.  
  270.  
  271.